home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / fat_string.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-05-24  |  13.4 KB  |  566 lines
  1. /*
  2. (c) Copyright W. Schelter 1988, All rights reserved.
  3. */
  4.  
  5. /* 16 bit strings  with leader, and raw slots in the leader t_fat_string */
  6.  
  7.  
  8. #include "include.h"
  9. #include "page.h"
  10. #define FAT_STRING
  11.  
  12. object  Sfat_string;
  13. enum type what_to_collect;
  14. #define    inheap(pp)    ((char *)(pp) < heap_end)
  15.  
  16.  
  17.  
  18. /* start fasdump stuff */
  19. #include "fasdump.c"
  20.  
  21. /* this will be used for lines, and for structures that require some
  22. raw storage */
  23.  
  24. #define check_fs_args(ar,ind) \
  25.     if (type_of(ar) != t_fat_string) FEerror("Not a vector with leader",0); \
  26.    if ((ind >= (ar->fs.fs_dim)) \
  27.        ||(ind < 0)) FEerror("subscript out of bounds",0)
  28.    
  29. check_type_fat_string(p)
  30. object *p;
  31. {
  32. BEGIN:
  33.     if (type_of(*p)==t_fat_string) return;
  34.     *p = wrong_type_argument(Sfat_string, *p);
  35.     goto BEGIN;
  36.       }
  37.       
  38.  
  39. void
  40. siLfsref()
  41. { check_arg(2);
  42.   {register int  ind = fix(vs_base[1]);
  43.    register object ar =  vs_base[0];
  44.    check_fs_args(ar,ind);
  45.    vs_base[0]=make_fixnum((int) (ar->fs.fs_self[ind]));
  46.    vs_top=vs_base+1;}}
  47.  
  48. void
  49. siLfsset()
  50. {register object *base,ar;
  51.  register int ind;
  52.  check_arg(3);
  53.  base=vs_base;
  54.  ar=base[0];
  55.  check_type_integer(&base[1]);
  56.  ind =fix(base[1]); 
  57.  check_fs_args(ar,ind);
  58.  base[0]=base[2];
  59.  ar->fs.fs_self[ind]=fix(base[0]);
  60.  vs_top=base+1;
  61. }
  62.  
  63. #define check_fs_leader(ar,ind) \
  64.       if (type_of(ar) != t_fat_string) FEerror("Not a vector with leader",0); \
  65.       if ((ind >= ar->fs.fs_leader_length)||(ind < 0)) FEerror("subscript out of bounds",0)
  66.  
  67.  
  68. fs_leader_ref(ar,ind)
  69.      register object ar;
  70.      register int ind;
  71. { check_arg(2);
  72.   check_fs_leader(ar,ind);
  73.   return (int) fs_leader(ar,ind);
  74. }
  75.  
  76.  
  77. void
  78. check_raw(raw,i)
  79.      unsigned int raw;
  80.      int i;
  81. {if (!(raw & (1 << i))) FEerror("Slot not raw",0);}
  82.  
  83.  
  84. void
  85. siLfs_leader_ref()
  86. { register object *base;
  87.   base=vs_base;
  88.   base[0]=(object) fs_leader_ref(base[0],fix(base[1]));
  89.   vs_top=base+1;
  90. }
  91.  
  92. void
  93. siLfixnum_fs_leader_ref()
  94. { register object *base;
  95.   base=vs_base;
  96.   check_raw((base[0]->fs.fs_raw),fix(base[1]));
  97.   base[0]=make_fixnum(fs_leader_ref(base[0],fix(base[1])));
  98.   vs_top=base+1;
  99. }
  100.  
  101.  
  102. void
  103. fs_leader_set(ar,ind,val)
  104.  register object ar;
  105.   register  int ind;
  106.      object val;
  107. {  check_arg(3);
  108.   check_fs_leader(ar,ind);
  109.   fs_leader(ar,ind)=  val;
  110. }
  111.  
  112.  
  113. void
  114. siLfs_leader_set()
  115. { register object *base;
  116.   base=vs_base;
  117.   fs_leader_set(base[0],fix(base[1]), base[2]);
  118.   base[0]=base[2];
  119.   vs_top=base+1;}
  120.  
  121. void
  122. siLfixnum_fs_leader_set()
  123. { register object *base;
  124.   base=vs_base;
  125.   check_type_integer(&base[2]);
  126.   check_raw((base[0])->fs.fs_raw,fix(base[1]));
  127.   fs_leader_set(base[0],fix(base[1]),(object) fix(base[2]));
  128.   base[0]=base[2];
  129.   vs_top=base+1;}
  130.  
  131. void
  132. mark_fat_string(x)
  133.      object x;
  134. {register char *cp;
  135.  { int i=0,raw=x->fs.fs_raw;
  136.    cp = (char *) x->fs.fs_self;
  137.    while (i < x->fs.fs_leader_length)
  138.      {if (raw & 1) ;
  139.       else mark_object(fs_leader(x,i));
  140.       raw=( raw >> 1); i++;
  141.     }}
  142.  {int leader_size = (x->fs.fs_leader_length) * sizeof(object *);
  143.   int body_size = leader_size + (x->fs.fs_dim)*sizeof(fatchar);
  144.   cp=cp-leader_size;
  145.   if ((int)what_to_collect >= (int)t_contiguous) {
  146.     if (inheap(cp)) {
  147.       if (what_to_collect == t_contiguous)
  148.     mark_contblock(cp,body_size);
  149.     }
  150.     else x->fs.fs_self =
  151.       (fatchar *) ((char *)copy_relblock(cp,body_size) + leader_size);
  152.   }}}
  153.    
  154. void
  155. siLfs_array_total_size()
  156. {vs_top=vs_base+1;
  157.   check_type_fat_string(&vs_base[0]);
  158.  vs_base[0]=make_fixnum(vs_base[0]->fs.fs_dim);
  159. }
  160.  
  161. void
  162. siLfs_fill_pointer()
  163. {vs_top=vs_base+1;
  164.   check_type_fat_string(&vs_base[0]);
  165.  vs_base[0]=make_fixnum(vs_base[0]->fs.fs_fillp);
  166. }
  167.  
  168.  
  169. void
  170. siLset_fs_fill_pointer()
  171. {check_arg(2);
  172.  check_type_fat_string(&vs_base[0]);
  173.  vs_top=vs_base+1;
  174.  vs_base[0]->fs.fs_fillp = fix(vs_base[1]);
  175. }
  176.  
  177.  
  178. object
  179. make_fat_string(dim,raw,lleng,staticp)
  180. int dim,raw,lleng;
  181. {object x;
  182.  x=alloc_object(t_fat_string);
  183.  vs_push(x);
  184.  x->fs.fs_dim=dim;
  185.  x->fs.fs_raw=raw;
  186.  x->fs.fs_leader_length=lleng;
  187.  x->fs.fs_fillp=0;
  188.  alloc_fs(x,staticp);
  189.  return x;
  190. }
  191.  
  192. void
  193. siLmake_fat_string()
  194. { register object *base;
  195.  check_arg(4);
  196.  base=vs_base;
  197.  base[0]=make_fat_string (fix(base[0]),fix(base[1]),fix(base[2]),
  198.               (base[3]!=Cnil));
  199.  vs_top=base+1;
  200. }
  201.  
  202.  
  203. alloc_fs(x,staticp)
  204. object x; int staticp;
  205. {char *cp, *actual_cp ;
  206.  register object *obp;
  207.  char *(*f)();
  208.  int leader_size=sizeof(object *)*(x->fs.fs_leader_length);
  209.  if (staticp)
  210.    f = alloc_contblock;
  211.  else
  212.    f = alloc_relblock;
  213.  obp=(object *)(cp= (*f)(sizeof(fatchar) * (x->fs.fs_dim)
  214.             +leader_size));
  215.  actual_cp=cp+leader_size;
  216.  while(obp <  (object *) actual_cp)
  217.    {*obp=Cnil;
  218.     obp++;}
  219.  x->fs.fs_self=(fatchar *)actual_cp;
  220. }
  221.  
  222.  
  223. object siLprofile_array;
  224. #ifdef NO_PROFILE
  225. profil()
  226. {;}
  227. #endif
  228.  
  229. void
  230. siLprofile() /*(start-address scale) where scale is 0 <= n <= 256 */
  231. {
  232. object ar=siLprofile_array->s.s_dbind;
  233. if (type_of(ar)!=t_string)
  234.       FEerror("si:*Profile-array* not a string",0);
  235. if((vs_top-vs_base != 2) ||
  236.    type_of(vs_base[0])!=t_fixnum ||   type_of(vs_base[1])!=t_fixnum)
  237.      FEerror("Needs start address and scale as args",0);
  238.   profil((char *) (ar->ust.ust_self), (ar->ust.ust_dim),
  239.        fix(vs_base[0]),fix(vs_base[1]) << 8);
  240. }
  241.  
  242. void
  243. siLfunction_start()
  244. {check_arg(1);
  245.  if(type_of(vs_base[0])!=t_cfun) FEerror("not compiled function",0);
  246.  vs_base[0]=make_fixnum((int) (vs_base[0]->cf.cf_self));
  247. }
  248.  
  249. /* begin fasl stuff*/
  250.  
  251. #include "ext_sym.h"
  252. #ifdef AIX3
  253. #include <sys/ldr.h>
  254. char *data_load_addr =0;
  255. #endif
  256.  
  257. read_special_symbols(symfile)
  258. char *symfile;
  259. {FILE *symin;
  260.  char *symbols;
  261.  int i,jj;
  262.  struct lsymbol_table tab;
  263. #ifdef AIX3
  264.  {char buf[500];
  265.   struct ld_info * ld;
  266.  loadquery(L_GETINFO,buf,sizeof(buf));
  267.   ld = (struct ld_info *)buf;
  268.   data_load_addr = ld->ldinfo_dataorg ;}
  269. #endif  
  270.  if (!(symin=fopen(symfile,"r")))
  271.    {perror(symfile);exit(1);};
  272.  if(!fread((char *)&tab,sizeof(tab),1,symin))
  273.    FEerror("No header",0);
  274.  symbols=malloc(tab.tot_leng);
  275.  c_table.alloc_length=( (PTABLE_EXTRA+ tab.n_symbols));
  276.  (c_table.ptable) = (TABL *) malloc(sizeof(struct node) * c_table.alloc_length);
  277.  if (!(c_table.ptable)) {perror("could not allocate"); exit(1);};
  278.  i=0; c_table.length=tab.n_symbols;
  279.  while(i < tab.n_symbols)
  280.    { fread((char *)&jj,sizeof(int),1,symin);
  281. #ifdef FIX_ADDRESS
  282.      FIX_ADDRESS(jj);
  283. #endif       
  284.      (SYM_ADDRESS(c_table,i))=jj;
  285.      SYM_STRING(c_table,i)=symbols;
  286.  
  287.      while( *(symbols++) =   getc(symin)) 
  288.        {;}
  289. /*     dprintf( name %s ,  SYM_STRING(c_table,i));
  290.      dprintf( addr %d , jj);
  291. */
  292.      i++;
  293.    }
  294.  
  295.  /*
  296.    for(i=0;i< 5;i++)
  297.    {printf("Symbol: %d %s %d \n",i,SYM_STRINGN(c_table,i),
  298.    SYM_ADDRESS(*ptable,i));}
  299.    */
  300.  if (symin) fclose(symin);
  301. }
  302.  
  303. node_compare(node1,node2)
  304. char *node1, *node2;
  305. { return(strcmp( ((struct node *)node1)->string,
  306.              ((struct node *)node2)->string));}
  307.  
  308.  
  309. void
  310. siLread_externals()
  311. {check_arg(1);
  312.  {object x=vs_base[0];
  313.   unsigned int n;
  314.   char *str;
  315.   n=x->st.st_fillp;
  316.  check_type_string(&x);
  317.  str=malloc(n+1);
  318.   str[n]=NULL;
  319.  (void) strncpy(str,x->st.st_self,n);
  320.  read_special_symbols(str);
  321.   /* we sort them since these are used by the sfasl loader too */
  322. qsort((char*)(c_table.ptable),(int)(c_table.length),sizeof(struct node),node_compare);
  323.  free(str);}}
  324.  
  325. #define CFUN_LIM 10000
  326.  
  327. int maxpage;
  328. object siLcdefn;
  329.  
  330. #define CF_FLAG (1 << 31) 
  331.  
  332.  
  333. cfuns_to_combined_table(n) /* non zero n will ensure new table length */
  334. unsigned int n;
  335. {int ii=0;  
  336.  STATIC int i, j;
  337.  STATIC object x;
  338.  STATIC char *p,*cf_addr;
  339.  STATIC struct typemanager *tm;
  340.  if (! (n || combined_table.ptable)) n=CFUN_LIM;
  341.  if (n && combined_table.alloc_length < n)
  342.    { 
  343.      (combined_table.ptable)=NULL;
  344.      (combined_table.ptable)= (TABL *)malloc(n* sizeof(struct node));
  345.      if(!combined_table.ptable)
  346.        FEerror("unable to allocate",0);
  347.      combined_table.alloc_length=n;}
  348.  
  349.  for (i = 0;  i < maxpage;  i++) {
  350.    if ((enum type)type_map[i]!=tm_table[(short)t_cfun].tm_type &&
  351.        (enum type)type_map[i]!=tm_table[(short)t_gfun].tm_type &&
  352.        (enum type)type_map[i]!=tm_table[(short)t_sfun].tm_type &&
  353.        (enum type)type_map[i]!=tm_table[(short)t_vfun].tm_type
  354.        )
  355.      continue;
  356.    tm = tm_of((enum type)type_map[i]);
  357.    p = pagetochar(i);
  358.    for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) {
  359.      x = (object)p;
  360.      if (type_of(x)!=t_cfun &&
  361.      type_of(x)!=t_sfun &&
  362.      type_of(x)!=t_vfun &&
  363.      type_of(x)!=t_gfun
  364.      ) continue;
  365.      if ((x->d.m == FREE) || x->cf.cf_self == NULL)
  366.        continue;
  367.     /* the cdefn things are the proclaimed call types. */
  368.      cf_addr=(char * ) ((unsigned int)(x->cf.cf_self));
  369.     
  370.      SYM_ADDRESS(combined_table,ii)=(unsigned int)cf_addr;
  371.      SYM_STRING(combined_table,ii)= (char *)(CF_FLAG | (unsigned int)x) ;
  372. /*       (x->cf.cf_name ? x->cf.cf_name->s.st_self : NULL) ; */
  373.      combined_table.length = ++ii;
  374.      if (ii >= combined_table.alloc_length)
  375.        FEerror("Need a larger combined_table",0);
  376.    }
  377.         
  378.  }
  379. }
  380.  
  381. address_node_compare(node1,node2)
  382. char *node1, *node2;
  383. {unsigned int a1,a2;
  384.  a1=((struct node *)node1)->address;
  385.  a2=((struct node *)node2)->address;
  386.  if (a1> a2) return 1;
  387.  if (a1< a2) return -1;
  388.  return 0;
  389. }
  390.  
  391.  
  392. void
  393. siLset_up_combined()
  394. {unsigned int n=0;
  395.  if (((vs_top - vs_base) == 1)&&type_of(vs_base[0])==t_fixnum)
  396.    n = (unsigned int) fix(vs_base[0]);
  397.  cfuns_to_combined_table(n);
  398.  if (c_table.ptable)
  399.    {int j,k;
  400.     if((k=combined_table.length)+c_table.length >=
  401.        combined_table.alloc_length)
  402.       cfuns_to_combined_table(combined_table.length+c_table.length +20);
  403.     for(j = 0; j < c_table.length;)
  404.     { SYM_ADDRESS(combined_table,k) =SYM_ADDRESS(c_table,j);
  405.       SYM_STRING(combined_table,k) =SYM_STRING(c_table,j);
  406.       k++;j++;
  407.     };
  408.     combined_table.length += c_table.length ;}
  409.  qsort((char*)combined_table.ptable,(int)combined_table.length,
  410.        sizeof(struct node),address_node_compare);
  411. }
  412.  
  413. static int  prof_start;
  414. prof_ind(address,scale)
  415.      unsigned int address;
  416. {address = address - prof_start ;
  417.  if (address > 0) return ((address * scale) >> 8) ;
  418.  return 0;
  419. }
  420.  
  421. /* sum entries AAR up to DIM entries */
  422. string_sum(aar,dim)
  423. register unsigned char *aar;
  424. unsigned int dim;
  425. {register unsigned char *endar;
  426.  register unsigned int count = 0;
  427. endar=aar+dim;
  428.  for ( ; aar< endar; aar++)
  429.    count += *aar;
  430.  return count;
  431. }
  432.  
  433. void
  434. siLdisplay_profile()
  435. {if (!combined_table.ptable)
  436.    FEerror("must symbols first",0);
  437.    check_arg(2);
  438.    {unsigned int prev,next,upto,dim,total;
  439.     int j,scale,count;
  440.     unsigned char *ar;
  441.     object obj_ar;
  442.     obj_ar=siLprofile_array->s.s_dbind;
  443.     if (type_of(obj_ar)!=t_string)
  444.       FEerror("si:*Profile-array* not a string",0);
  445.     ar=obj_ar->ust.ust_self;
  446.     scale=fix(vs_base[1]);
  447.     prof_start=fix(vs_base[0]);
  448.     vs_top=vs_base;
  449.     dim= (obj_ar->ust.ust_dim);
  450.  
  451.     total=string_sum(ar,dim);
  452.   
  453.     j=0;
  454.     {int i, finish = combined_table.length-1;
  455.      for(i =0,prev=SYM_ADDRESS(combined_table,i); i< finish;
  456.      prev=next)
  457.        { ++i;
  458.      next=SYM_ADDRESS(combined_table,i);
  459.      if ( prev < prof_start) continue;
  460.      upto=prof_ind(next,scale);
  461.      if (upto >= dim) upto=dim;
  462.      {char *name; unsigned int uname;
  463.       count=0;
  464.       for( ; j<upto;j++)
  465.         count += ar[j];
  466.       if (count > 0) {
  467.         name=SYM_STRING(combined_table,i-1);
  468.         uname = (unsigned int) name;
  469.         printf("\n%6.2f%% (%5d): ",(100.0*count)/total, count);
  470.         fflush(stdout);
  471.         if (CF_FLAG & uname)
  472.           {if (~CF_FLAG & uname) prin1( ((object) (~CF_FLAG & uname))->cf.cf_name,Cnil);}
  473.          else if (name ) printf("%s",name);};
  474.       if (upto==dim) goto TOTALS ;
  475.       
  476.     }}}
  477.  TOTALS:
  478.   printf("\nTotal ticks %d",total);fflush(stdout);
  479. }}
  480.  
  481. #ifdef SFASL
  482. int build_symbol_table();
  483. #endif
  484.  
  485.  
  486. /* end fasl stuff*/
  487.  
  488.  
  489. /* These are some low level hacks to allow determining the address
  490.    of an array body, and to allow jumping to inside the body
  491.    of the array */
  492.  
  493. siLarray_adress()
  494. {check_arg(1);
  495.  vs_base[0]=make_fixnum((int) (&(vs_base[0]->st.st_self[0])));
  496. }
  497.  
  498. /* This is some very low level code for hacking invokation of
  499.    m68k instructions in a lisp array.  The index used should be
  500.    a byte index.  So invoke(ar,3) jmps to byte ar+3.
  501.    */
  502.  
  503. #ifdef CLI
  504.  
  505. invoke(ar)
  506. char *ar;
  507. {asm("movel a6@(8),a0");
  508.  asm("jmp a0@");
  509. }
  510. /* save regs (2 3 4 5 6 7  10 11 12 13 14) and invoke restoring them */
  511. save_regs_invoke(ar)
  512. char *ar;
  513. {asm("moveml #0x3f3e,sp@-");
  514.  invoke(ar);
  515.  asm("moveml a6@(-44),#0x7cfc");
  516. }
  517. siLsave_regs_invoke()
  518. {int x;
  519.  check_arg(2);
  520.   check_type_integer(&vs_base[1]);
  521.   x=save_regs_invoke((vs_base[0]->st.st_self)+fix(vs_base[1]));
  522.  vs_top=vs_base+1;
  523.  vs_base[0]=make_fixnum(x);
  524. }
  525.  
  526.  
  527. #endif
  528.  
  529. init_fat_string()
  530. {make_si_function("ARRAY-ADDRESS",siLarray_adress);
  531. #ifdef CLI
  532.  make_si_function("SAVE-REGS-INVOKE",siLsave_regs_invoke);
  533. #endif 
  534.  make_si_function("FSREF",siLfsref);
  535.  make_si_function("FSSET",siLfsset);
  536.  make_si_function("FS-LEADER-REF",siLfs_leader_ref);
  537.  make_si_function("FS-LEADER-SET",siLfs_leader_set);
  538.  make_si_function("FIXNUM-FS-LEADER-SET",siLfixnum_fs_leader_set);
  539.  make_si_function("FIXNUM-FS-LEADER-REF",siLfixnum_fs_leader_ref);
  540.  make_si_function("SET-FS-FILL-POINTER",siLset_fs_fill_pointer);
  541.  make_si_function("FS-ARRAY-TOTAL-SIZE",siLfs_array_total_size);
  542.  make_si_function("FS-FILL-POINTER",siLfs_fill_pointer);
  543.  make_si_function("MAKE-FAT-STRING",siLmake_fat_string);
  544.  make_si_function("FUNCTION-START",siLfunction_start);
  545.  make_si_function("PROFILE",siLprofile);
  546.  make_si_function("READ-EXTERNALS",siLread_externals);
  547.  make_si_function("SET-UP-COMBINED",siLset_up_combined);
  548.  make_si_function("DISPLAY-PROFILE",siLdisplay_profile);
  549.  make_si_constant("*ASH->>*",(-1==(((int)-1) >> 50))? Ct :Cnil);
  550. #ifdef SFASL
  551.  make_si_function("BUILD-SYMBOL-TABLE",build_symbol_table);
  552. #endif
  553.  siLprofile_array=make_si_special("*PROFILE-ARRAY*",Cnil);
  554.  Sfat_string = make_ordinary("FAT-STRING");
  555.  enter_mark_origin(&Sfat_string);
  556.  init_fasdump();
  557.  
  558. }
  559.  
  560.  
  561.  
  562.  
  563.  
  564.  
  565.  
  566.